home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
090
/
byt1186b.arc
/
RUNGKUT.LBR
/
THERM.FOR
< prev
Wrap
Text File
|
1986-04-11
|
1KB
|
49 lines
implicit double precision (a-h,o-z)
dimension y(1), work(17), icom(4)
external thermo
common etherm,ifeval,j
open(2,file=' ',status='new')
ifeval=0
icom(1)=0
icom(2)=0
icom(3)=0
neqn=1
write(*,*) 'etherm=, imeth=, tola=, tolr='
read(*,*) etherm,imeth,tola,tolr
hstart=0.01d0
y(1)=1.d0
x0=0.d0
xb=0.d0
do 20 j=1,6
xa=xb
xb=0.2d0*dble(j)+x0
abserr=dexp(-etherm*xa)-y(1)
relerr=abserr/dexp(-etherm*xa)
write(2,100)xa,y(1),abserr,relerr
call runkut(xa,y,xb,neqn,tola,tolr,hstart,work,
& imeth,ierror,icom,thermo)
if(ierror.GT.1) then
write(2,100)xb,y(1),abserr,relerr
write(2,*)' ERROR-Problem too stiff or is discontinous'
close(2)
stop
end if
20 continue
if(icom(4).GT.0) write(2,*) 'Round-off error possible'
write(2,*) 'Number of function evaluations = ',ifeval
close (2)
stop
100 format(F10.5,4E14.6)
end
c**********************************************************************
subroutine thermo (x,y,yprime,neqn)
implicit double precision (a-h,o-z)
dimension y(neqn), yprime(neqn)
common etherm,ifeval,j
yprime(1)= -etherm*y(1)
if(j.LE.5) ifeval=ifeval+1
return
end